home *** CD-ROM | disk | FTP | other *** search
/ Skunkware 98 / Skunkware 98.iso / src / interp / perl5.005.tar.gz / perl5.005.tar / perl5.005 / t / op / tiearray.t < prev    next >
Text File  |  1998-07-19  |  4KB  |  211 lines
  1. #!./perl
  2.  
  3.  
  4. BEGIN {
  5.     chdir 't' if -d 't';
  6.     @INC = '../lib';
  7. }
  8.  
  9. my %seen;
  10.  
  11. package Implement;
  12.  
  13. sub TIEARRAY
  14. {
  15.  $seen{'TIEARRAY'}++;
  16.  my ($class,@val) = @_;
  17.  return bless \@val,$class;
  18. }
  19.  
  20. sub STORESIZE
  21. {        
  22.  $seen{'STORESIZE'}++;
  23.  my ($ob,$sz) = @_; 
  24.  return $#{$ob} = $sz-1;
  25. }
  26.  
  27. sub EXTEND
  28. {        
  29.  $seen{'EXTEND'}++;
  30.  my ($ob,$sz) = @_; 
  31.  return @$ob = $sz;
  32. }
  33.  
  34. sub FETCHSIZE
  35. {        
  36.  $seen{'FETCHSIZE'}++;
  37.  return scalar(@{$_[0]});
  38. }
  39.  
  40. sub FETCH
  41. {
  42.  $seen{'FETCH'}++;
  43.  my ($ob,$id) = @_;
  44.  return $ob->[$id]; 
  45. }
  46.  
  47. sub STORE
  48. {
  49.  $seen{'STORE'}++;
  50.  my ($ob,$id,$val) = @_;
  51.  $ob->[$id] = $val; 
  52. }                 
  53.  
  54. sub UNSHIFT
  55. {
  56.  $seen{'UNSHIFT'}++;
  57.  my $ob = shift;
  58.  unshift(@$ob,@_);
  59. }                 
  60.  
  61. sub PUSH
  62. {
  63.  $seen{'PUSH'}++;
  64.  my $ob = shift;;
  65.  push(@$ob,@_);
  66. }                 
  67.  
  68. sub CLEAR
  69. {
  70.  $seen{'CLEAR'}++;
  71.  @{$_[0]} = ();
  72. }
  73.  
  74. sub DESTROY
  75. {
  76.  $seen{'DESTROY'}++;
  77. }
  78.  
  79. sub POP
  80. {
  81.  $seen{'POP'}++;
  82.  my ($ob) = @_;
  83.  return pop(@$ob);
  84. }
  85.  
  86. sub SHIFT
  87. {
  88.  $seen{'SHIFT'}++;
  89.  my ($ob) = @_;
  90.  return shift(@$ob);
  91. }
  92.  
  93. sub SPLICE
  94. {
  95.  $seen{'SPLICE'}++;
  96.  my $ob  = shift;                    
  97.  my $off = @_ ? shift : 0;
  98.  my $len = @_ ? shift : @$ob-1;
  99.  return splice(@$ob,$off,$len,@_);
  100. }
  101.  
  102. package main;
  103.  
  104. print "1..31\n";                   
  105. my $test = 1;
  106.  
  107. {my @ary;
  108.  
  109. { my $ob = tie @ary,'Implement',3,2,1;
  110.   print "not " unless $ob;
  111.   print "ok ", $test++,"\n";
  112.   print "not " unless tied(@ary) == $ob;
  113.   print "ok ", $test++,"\n";
  114. }
  115.  
  116.  
  117. print "not " unless @ary == 3;
  118. print "ok ", $test++,"\n";
  119.  
  120. print "not " unless $#ary == 2;
  121. print "ok ", $test++,"\n";
  122.  
  123. print "not " unless join(':',@ary) eq '3:2:1';
  124. print "ok ", $test++,"\n";         
  125.  
  126. print "not " unless $seen{'FETCH'} >= 3;
  127. print "ok ", $test++,"\n";
  128.  
  129. @ary = (1,2,3);
  130.  
  131. print "not " unless $seen{'STORE'} >= 3;
  132. print "ok ", $test++,"\n";
  133. print "not " unless join(':',@ary) eq '1:2:3';
  134. print "ok ", $test++,"\n";         
  135.  
  136. {my @thing = @ary;
  137. print "not " unless join(':',@thing) eq '1:2:3';
  138. print "ok ", $test++,"\n";         
  139.  
  140. tie @thing,'Implement';
  141. @thing = @ary;
  142. print "not " unless join(':',@thing) eq '1:2:3';
  143. print "ok ", $test++,"\n";
  144. } 
  145.  
  146. print "not " unless pop(@ary) == 3;
  147. print "ok ", $test++,"\n";
  148. print "not " unless $seen{'POP'} == 1;
  149. print "ok ", $test++,"\n";
  150. print "not " unless join(':',@ary) eq '1:2';
  151. print "ok ", $test++,"\n";
  152.  
  153. push(@ary,4);
  154. print "not " unless $seen{'PUSH'} == 1;
  155. print "ok ", $test++,"\n";
  156. print "not " unless join(':',@ary) eq '1:2:4';
  157. print "ok ", $test++,"\n";
  158.  
  159. my @x = splice(@ary,1,1,7);
  160.  
  161.  
  162. print "not " unless $seen{'SPLICE'} == 1;
  163. print "ok ", $test++,"\n";
  164.  
  165. print "not " unless @x == 1;
  166. print "ok ", $test++,"\n";
  167. print "not " unless $x[0] == 2;
  168. print "ok ", $test++,"\n";
  169. print "not " unless join(':',@ary) eq '1:7:4';
  170. print "ok ", $test++,"\n";             
  171.  
  172. print "not " unless shift(@ary) == 1;
  173. print "ok ", $test++,"\n";
  174. print "not " unless $seen{'SHIFT'} == 1;
  175. print "ok ", $test++,"\n";
  176. print "not " unless join(':',@ary) eq '7:4';
  177. print "ok ", $test++,"\n";             
  178.  
  179. my $n = unshift(@ary,5,6);
  180. print "not " unless $seen{'UNSHIFT'} == 1;
  181. print "ok ", $test++,"\n";
  182. print "not " unless $n == 4;
  183. print "ok ", $test++,"\n";
  184. print "not " unless join(':',@ary) eq '5:6:7:4';
  185. print "ok ", $test++,"\n";
  186.  
  187. @ary = split(/:/,'1:2:3');
  188. print "not " unless join(':',@ary) eq '1:2:3';
  189. print "ok ", $test++,"\n";         
  190.   
  191. my $t = 0;
  192. foreach $n (@ary)
  193.  {
  194.   print "not " unless $n == ++$t;
  195.   print "ok ", $test++,"\n";         
  196.  }
  197.  
  198. @ary = qw(3 2 1);
  199. print "not " unless join(':',@ary) eq '3:2:1';
  200. print "ok ", $test++,"\n";         
  201.  
  202. untie @ary;   
  203.  
  204. }
  205.                            
  206. print "not " unless $seen{'DESTROY'} == 2;
  207. print "ok ", $test++,"\n";         
  208.  
  209.  
  210.  
  211.